home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994…tember: Reference Library / Dev.CD Sep 94.toast / Periodicals / develop / develop Issue 19 / develop 19 code / SimpliFace_V2 / Sources / CTdebugWriteln.p < prev    next >
Encoding:
Text File  |  1992-10-18  |  6.1 KB  |  298 lines  |  [TEXT/MPS ]
  1. UNIT CTdebugWriteln;
  2.  
  3.  
  4.  
  5. INTERFACE
  6.  
  7.  
  8. PROCEDURE InstallWriteLnHook;
  9.  
  10. PROCEDURE StartDebug;
  11.  
  12. PROCEDURE EndDebug;
  13.  
  14. PROCEDURE SetDebugLevel(newLevel: INTEGER);
  15.  
  16. FUNCTION  GetDebugLevel: INTEGER;
  17.  
  18.  
  19.  
  20. IMPLEMENTATION
  21.  
  22. USES
  23.     
  24.     Types, Traps, Memory, Quickdraw, 
  25.     OSIntf, ToolIntf, PackIntf, PPCToolbox,
  26.     
  27.     Events, AppleEvents,
  28.     
  29.     IntEnv, 
  30.     
  31.     PasLibIntf,
  32.     DisAsmLookup,
  33.     Unmangler,
  34.     
  35.     AEregistry,
  36.     
  37.     CTdebugStream;
  38.  
  39. VAR
  40.  
  41. {$SETC qDebugProcEnds:= TRUE}
  42.  
  43.     gDebugProcNest:     INTEGER;
  44.     gDebugWriteln:        INTEGER;
  45.  
  46. {--------------------------------------------------------------------------------------------------}
  47.     
  48.     {$Push} {$J+}
  49.     PFILENAME:            Str255;                            { Name of file to intercept for IO }
  50.  
  51.     pDebugWindow:        WindowPtr;                        { the window object that contains the debug
  52.                                                          window }
  53.     {$Pop}
  54.  
  55. {--------------------------------------------------------------------------------------------------}
  56.  
  57. {$S Main}
  58.  
  59. FUNCTION DevFAccess(fName: UNIV Ptr;
  60.                     opCode: Longint;
  61.                     arg: UNIV Longint): Longint;
  62.     C; EXTERNAL;
  63.  
  64. FUNCTION DevClose(fdesc: UNIV Longint): Longint;
  65.     C; EXTERNAL;
  66.  
  67. FUNCTION DevRead(fdesc: UNIV Longint;
  68.                  bufp: UNIV Longint;
  69.                  count: Longint): Longint;
  70.     C; EXTERNAL;
  71.  
  72. FUNCTION DevWrite(fdesc: UNIV Longint;
  73.                   bufp: UNIV Longint;
  74.                   count: Longint): Longint;
  75.     C; EXTERNAL;
  76.  
  77. FUNCTION DevIoctl(fdesc: UNIV Longint;
  78.                   request: Longint;
  79.                   arg: UNIV Longint): Longint;
  80.     C; EXTERNAL;
  81.  
  82. FUNCTION _addDevHandler(slot, dvName, dvFAccess, dvClose, dvRead, dvWrite,
  83.                         dvIoctl: Longint): Longint;
  84.     C; EXTERNAL;
  85.  
  86. {--------------------------------------------------------------------------------------------------}
  87.  
  88. FUNCTION SetGetProc(theGetProc: ProcPtr): ProcPtr;
  89.     EXTERNAL;
  90.  
  91. FUNCTION SetPutProc(thePutProc: ProcPtr): ProcPtr;
  92.     EXTERNAL;
  93.  
  94. {--------------------------------------------------------------------------------------------------}
  95.  
  96. {*****************************************************************************}
  97. {
  98.     For debugging purposes only - Utility Routines
  99. }
  100.  
  101. {$Push} {$Z+} {$%+}
  102.     
  103.     
  104.     FUNCTION GetParmBlockPtr: LONGINT;
  105.         INLINE $2E88;                                { MOVE.L A0,(A7) }
  106.     { Formerly, %_GetA0. Return the value of register A0.  Useful for getting the pointer
  107.     to the parameter block from a VBL task or a completion routine. }
  108.  
  109.     FUNCTION GetA5: LONGINT;
  110.         INLINE $2E8D;                                { MOVE.L A5,(A7) }
  111.     { Formerly, %_GetA5. Return the value of register A5. Useful for getting the immediate value
  112.     of A5 which is not always the same as CurrentA5.  Generally a pointer to the program's
  113.     global area and jump table. }
  114.  
  115.     FUNCTION GetCurStackFramePtr: Ptr;
  116.         INLINE $2E8E;                                { MOVE.L A6,(A7) }
  117.     { Formerly, %_GetA6. Return the value of register A6.  Usually a pointer to the local stack
  118.     frame.    Most often used to find out the caller's name when invoking a debugging routine. }
  119.  
  120.     FUNCTION GetCurStackTop: Ptr;
  121.         INLINE $2E8F;                                { MOVE.L A7,(A7) }
  122.     { Formerly, %_GetA7. Return the value of register A7.  Usually the top of stack.  Useful
  123.     for stack sniffing (not a crime). }
  124.  
  125.     PROCEDURE GetProcName(ppc: Longint;
  126.                           VAR procName: Str255);
  127.     { GetProcName returns the name of the procedure or function in
  128.     which ppc points.  }
  129.     VAR
  130.         pc, nextPC, limit:    Ptr;
  131.         tmpName:            Str255;
  132.     BEGIN
  133.         pc := Handle(ppc)^;
  134.         IF (ord(pc) <> 0) & NOT Odd(ord(pc)) THEN
  135.             BEGIN
  136.             limit := Ptr(ord(pc) + 32767);
  137.             WHILE (endOfModule(pc, limit, @procName, nextPC) = NIL) DO
  138.                 BEGIN
  139.                 IF ord(pc) >= ord(limit) THEN
  140.                     BEGIN
  141.                     procName := '';
  142.                     LEAVE;
  143.                     END
  144.                 ELSE
  145.                     pc := Ptr(ord(pc) + 2);
  146.                 END;
  147.     
  148.             END
  149.         ELSE
  150.             BEGIN
  151.             procName := '';
  152.             END;
  153.         IF procName <> '' THEN
  154.             BEGIN
  155.             IF Unmangle(@tmpName, @procName, 255) > 0 THEN
  156.                 procName:= tmpName;
  157.             END;
  158.     END;
  159.  
  160.     PROCEDURE DumpFuncInfo(msg: Str255; aPLink, aPpc: Longint);
  161.     VAR
  162.         pName:    Str255;
  163.     BEGIN
  164.         GetProcName(aPpc, pName);
  165.         
  166.         StrLineToDebugger(concat(msg, pName));
  167.         
  168.         PLFlush(output);
  169.     END;
  170.     
  171.     PROCEDURE DebugNest(onEntry: BOOLEAN);
  172.     BEGIN
  173.         IF onEntry THEN
  174.             gDebugProcNest:= gDebugProcNest + 1;
  175.  
  176. {$IFC NOT qDebugProcEnds}            
  177.         IF onEntry THEN
  178. {$ENDC}
  179.             Str255ToDebugger(copy('..............................', 1, gDebugProcNest));
  180.             
  181.         IF NOT onEntry THEN
  182.             gDebugProcNest:= gDebugProcNest - 1;
  183.     END;
  184.     
  185.     PROCEDURE %_BP;
  186.     VAR
  187.         OldA5:                Longint;
  188.     BEGIN
  189.     { OldA5 := SetCurrentA5; }                                {}
  190.     
  191.     DebugNest(TRUE);
  192.     DumpFuncInfo('-> ', 
  193.                  Ord4(GetCurStackFramePtr), Ord4(GetCurStackFramePtr) + 4);
  194.     
  195.     { OldA5 := SetA5(OldA5); }                                {}
  196.     END;
  197.  
  198.     PROCEDURE %_EP;
  199.     VAR
  200.         OldA5:                Longint;
  201.     BEGIN
  202.     { OldA5 := SetCurrentA5; }                                {}
  203.     DebugNest(FALSE);
  204.  
  205. {$IFC qDebugProcEnds}            
  206.     DumpFuncInfo('<- ', 
  207.                  Ord4(GetCurStackFramePtr), Ord4(GetCurStackFramePtr) + 4);
  208. {$ENDC}
  209.  
  210.     { OldA5 := SetA5(OldA5); }                                {}
  211.     END;
  212.  
  213.     PROCEDURE %_EX;
  214.     VAR
  215.         OldA5:                Longint;
  216.     BEGIN
  217.     { OldA5 := SetCurrentA5; }                                {}
  218.     DebugNest(FALSE);
  219.  
  220. {$IFC qDebugProcEnds}            
  221.     DumpFuncInfo('<x ', 
  222.                  Ord4(GetCurStackFramePtr), Ord4(GetCurStackFramePtr) + 4);
  223. {$ENDC}
  224.  
  225.     { OldA5 := SetA5(OldA5); }                                {}
  226.     END;
  227.     
  228. {$Pop}
  229.  
  230. {*****************************************************************************}
  231.  
  232. PROCEDURE DebugWriteLn(textBuf: Ptr;
  233.                        byteCount: INTEGER);
  234. BEGIN
  235.     IF gDebugWriteln > 0 THEN
  236.         StreamToDebugger(textBuf, byteCount);
  237. END;
  238.  
  239.  
  240. FUNCTION DebugReadLn(buffer: Ptr;
  241.                      byteCount: INTEGER): Longint;
  242. BEGIN
  243.     DebugReadLn:= 0;
  244. END;
  245.  
  246.  
  247. PROCEDURE InstallWriteLnHook;
  248. CONST
  249.     kConsoleName        = 'Dev:Console';
  250.     _CODEV                = 1;                        { console device number }
  251. VAR
  252.     slot:                Longint;
  253.     oldProc:            ProcPtr;
  254. BEGIN
  255.     gDebugProcNest:= 0;
  256.     gDebugWriteln:= -2;
  257.     
  258.     PFILENAME := kConsoleName;
  259.     slot := _addDevHandler(_CODEV, 0, ord(@DevFAccess), ord(@DevClose), ord(@DevRead),
  260.                            ord(@DevWrite), ord(@DevIoctl));
  261.     PLsetvbuf(output, NIL, _IOLBF, 512);
  262.     oldProc := SetGetProc(@DebugReadLn);
  263.     oldProc := SetPutProc(@DebugWriteLn);
  264. END;
  265.  
  266.  
  267.  
  268. PROCEDURE StartDebug;
  269. BEGIN
  270.     gDebugWriteln:= gDebugWriteln + 1;
  271. END;
  272.  
  273.  
  274.  
  275. PROCEDURE EndDebug;
  276. BEGIN
  277.     gDebugWriteln:= gDebugWriteln - 1;
  278. END;
  279.  
  280.  
  281. PROCEDURE SetDebugLevel(newLevel: INTEGER);
  282. BEGIN
  283.     gDebugWriteln:= newLevel;
  284. END;
  285.  
  286.  
  287. FUNCTION  GetDebugLevel: INTEGER;
  288. BEGIN
  289.     GetDebugLevel:= gDebugWriteln;
  290. END;
  291.  
  292.  
  293. {--------------------------------------------------------------------------------------------------}
  294.  
  295.  
  296.  
  297. END.
  298.